BBS in a Box 3

home *** CD-ROM | disk | FTP | other *** search

/ BBS in a Box 3 / BBS in a box - Trilogy III.iso / Files / Prog / N-P / Pocket6.3 / Examples / Reader < prev next >

Wrap

Text File | 1993-06-29 | 21.2 KB | 522 lines | [TEXT/McSk]

( Reader application for Pocket Forth 0.6.3 ) : RTEST ( -- ) key 13 = 0= IF bye ?terminal drop THEN 0 28 +md ! ; page ( ******************* W A R N I N G ******************** ) \ This file creates the ReadMe application. Do NOT run \ this file on a normal copy of Pocket Forth. Instead make \ a SPECIAL copy using ResEdit: \ 1} Open a copy of ReadMe with ResEdit \ 2} Delete the DICT 257 resource from ReadMe \ 3} Open a copy of Pocket Forth with ResEdit \ 4} Copy the DICT 257 resource from Pocket Forth \ 5} Paste the DICT 257 resource into ReadMe \ 6} Save ReadMe with ResEdit \ 7} Quit ResEdit and Open ReadMe \ 8} Type "open" and open Reader \ 9} Press the return key, wait until ReadMe quits. \ 10} Restart ReadMe. ( Type return to continue, anything else to quit. ) rtest forget task : task ; : !FONT ( n -- ) >r ,$ A887 ; macro ( _TextFont ) : !FSIZE ( n -- ) >r ,$ A88A ; macro ( _TextSize ) : !FACE ( face -- ) >r ,$ A888 ; macro ( _TextFace ) : SFONT ( -- ) 0 !font 12 !fsize ; ( 12 point Chicago ) : NFONT ( -- ) 4 !font 12 !fsize ; \ 12 point Monaco : LFONT ( -- ) nfont 9 !fsize ; \ 9 point Monaco : TFONT ( -- ) 20 !font 9 !fsize ; \ 9 point Times : CLS ( -- ) 4 +md a>r ,$ A8A3 20 20 !pen ; ( CLear Screen ) ( old style colors ) : BLACK 33 0 2>r ,$ A862 ; ( black _ForeColor ) : RED 205 0 2>r ,$ A862 ; ( red _ForeColor ) : BLUE 409 0 2>r ,$ A862 ; ( blue _ForeColor ) : YELLOW 69 0 2>r ,$ A863 ; ( yellow _BackColor ) : WITE 30 0 2>r ,$ A863 ; ( white _BackColor ) ( rect words ) : RECT ( compile: -- ) ( run: -- addr ) variable 6 allot ; : !RECT ( t l b r rect -- ) >r swap r 4 + 2! swap r> 2! ; : @RECT ( rect -- t l b r ) dup 2@ swap rot 4 + 2@ swap ; : ROFFSET ( h v rect -- ) a>r 2>r ,$ A8A8 ; ( _OffsetRect ) : RINSET ( h v rect -- ) a>r 2>r ,$ A8A9 ; ( _InsetRect ) : ?EMPTY ( rect -- flag ) 0 >r a>r ,$ A8AE r> ; ( _EmptyRect ) : RERASE ( rect -- ) a>r ,$ A8A3 ; ( _EraseRect ) : ?PHIT ( h v poly -- flag ) ( true if h,v is in polyBBox ) 0 >r 2@ dl@ 2 0 d+ 2swap 2>r 2>r ,$ A8AD r> ; ( _PtInRect ) : POLYGON ( addr -- ) 0 0 2>r ,$ A8CB 2r> rot 2! ; ( _OpenPoly ) ( print PICT resources from this file ) : GETPICT ( id -- dhandle ) 0 0 2>r >r ,$ A9BC 2r> ; ( _GetPict ) : PDRAW ( rect dhandle -- ) ( draw a picture in rect ) 2>r a>r ,$ A8F6 ; ( _DrawPicture ) : DPICT ( rect id -- ) getpict pdraw ; ( create and destroy pictures ) : PICTURE ( rect -- dhandle ) ( open a picture ) 0 0 2>r a>r ,$ A8F3 2r> ; ( _OpenPicture ) : PCLOSE ,$ A8F4 ; macro ( _ClosePicture ) : PKILL ( addr -- ) 2@ 2>r ,$ A8F5 ; ( _KillPicture at addr ) \ color availability testing : ?COLOR ( -- f ) \ true if color is available and system>6.0.4 ,s qd ?gestalt dup IF 2drop 256 < 0= THEN ; : GDEVICE ( -- dhandle ) \ handle of grafics device 0 0 2>r ,$ aa32 2r> ; ( _getGDevice ) : BITS/PIXEL ( -- n ) \ n = bit depth of monitor setting ?color IF gdevice dl@ 22 s>d d+ \ handle of pixmap dl@ dl@ 32 s>d d+ l@ \ get the pixsize ELSE 1 THEN ; ( icons ) : CIGET ( id -- d.handle ) ( call once per icon ) 0 0 2>r >r \ push room and id ?color IF ,$ AA1E ( _GetCIcon ) ELSE ,$ A9BB THEN 2r> ; ( _GetIcon ) : CIPLOT ( rect d.handle -- ) \ draw icon in rect rot a>r 2>r ?color IF ,$ AA1F ( _PlotCIcon ) ELSE ,$ A94B THEN ; ( _PlotIcon ) ( polygons for the 'NEXT' and 'PREV' "buttons" ) 2variable APOLY ( aft button poly handle ) 2variable FPOLY ( fore button poly handle ) : +APOLY ( -- ) apoly polygon 5 225 !pen 20 210 -to 50 210 -to 50 240 -to 20 240 -to 5 225 -to ,$ A8CC ; ( _ClosePgon ) : +FPOLY ( -- ) fpoly polygon 440 225 !pen 425 210 -to 390 210 -to 390 240 -to 425 240 -to 440 225 -to ,$ A8CC ; ( _ClosePgon ) ( display "buttons" ) : .POLY ( addr -- ) blue 2@ 2>r ,$ A8C6 black ; ( _FramePoly ) : .AARROW ( -- ) 015 230 !pen ." Prev" apoly .poly ; : .FARROW ( -- ) 396 230 !pen ." Next" fpoly .poly ; : .ARROWS ( -- ) .aarrow .farrow ; \ display icons variable ICONTABLE 0 iconTable ! 12 allot \ room for 2 icons ( no.of.entries id#1 handle#1 id#2 handle#2 ) : >ICON ( index -- addr ) 6 * iconTable 2+ + ; \ icon list entry (0 based) : +ICON ( id -- ) \ loads icon from disk and stores data in table iconTable @ >icon \ get entry address 2dup ! \ store id into table swap ciget rot 2+ 2! \ get & store handle 1 iconTable +! ; : .ICON ( id rect -- ) \ display icon in rect SWAP iconTable @ 0 DO \ search the icon table .. r >icon @ over = IF \ .. for the id wanted drop r >icon 2+ 2@ ciplot LEAVE THEN LOOP ; \ Flying Bird stuff rect BRECT 0 0 14 28 brect !rect ( the bird's rect ) rect OBRECT 0 0 0 0 obrect !rect ( old brect ) 2variable B1PICT ( hold b1's pict handle ) 2variable B2PICT ( hold b2's pict handle ) 2variable B3PICT ( hold b3's pict handle ) ( draw the three bird positions ) : .B1 red 2 0 !pen 6 0 -to 12 6 -to 18 0 -to 22 0 -to black ; : .B2 red 0 6 !pen 24 6 -to black ; : .B3 red 2 12 !pen 6 12 -to 12 6 -to 18 12 -to 22 12 -to black ; : +BIRD \ initialize the birds pictures & store the handles brect picture .b1 pclose b1pict 2! brect picture .b2 pclose b2pict 2! brect picture .b3 pclose b3pict 2! 0 0 0 0 brect !rect 0 0 0 0 obrect !rect ; : -BIRD b1pict pkill b2pict pkill b2pict pkill ; : B1 brect b1pict 2@ pdraw ; : B2 brect b2pict 2@ pdraw ; : B3 brect b3pict 2@ pdraw ; create .BS ' b1 , ' b2 , ' b3 , ( bird draw array ) variable BTHIS 0 bthis ! ( offset to the current routine ) 4 constant #BIRDS \ (number_of_birds-1)*2 : THISBIRD ( -- n ) bthis @ ; \ the current bird : NEXTBIRD ( -- ) 2 bthis +! ; \ set bthis to the next bird : FIRSTBIRD ( -- ) 0 bthis ! ; \ first picture in sequence : .BIRD ( n -- ) .bs + @ execute ; \ draw bird n : MOVEBIRD 3 -1 brect roffset ; \ translate brect down1 for 3right : SHRINKBIRD 1 1 brect rinset ; \ shrink brect by 2 pixels : ANIMATE ( -- ) ( draw the flying red bird ) brect ?empty IF \ if bird has shrunk to oblivion... 48 291 60 309 brect !rect THEN \ ...restore its origonal size bits/pixel 1 > IF yellow THEN obrect rerase wite \ erase the old rect brect @rect obrect !rect \ set old rect to current rect 0 -1 obrect rinset \ expand old rect for full erasure thisBird .bird ( draw the bird ) thisBird #birds < IF \ if its bird 1 or 2 nextBird moveBird \ increment bird and move rect ELSE \ its bird 3 firstBird moveBird shrinkBird \ cycle, move & shrink ) 2 >r ,$ A889 ( SrcXor _TextMode ) \ 50 30 !pen ." NEW! IMPROVED!" THEN ; ( rects for pictures ) rect PRECT 15 48 212 405 prect !rect ( title picture rect ) rect CRECT 15 181 210 405 crect !rect ( title picture rect ) rect SRECT 192 222 221 370 srect !rect ( signature rect ) rect IRECT 170 194 203 227 irect !rect ( icon rect ) : SCR ( -- ) @pen swap drop 16 + 50 swap !pen ; ( special cr ) : BCR ( -- ) @pen swap drop 50 swap !pen ; ( cr without lf ) ( P1 - P? are page drawing routines. They have no stack effect.) : P1 cls prect 4000 dpict bits/pixel 1 > IF crect 4002 dpict THEN 5 247 !pen tfont ." Read Me special edition." sfont .farrow ; : P2 cls scr ." Its FAST, its FUN and its FREE!" scr scr ." Its Pocket Forth, a programming language for" scr ." writing Macintosh applications and DAs." cr scr ." You can take advantage of many new features" scr ." in this release such as Apple Events*, Floating" scr ." Point, Gestalt** and Drag & Drop* programming." cr scr ." Learn Forth programming with the contents of" scr ." the Starting folder (inside the Extensions folder.)" scr scr scr ." * System 7 ** System 6.0.4+" srect 4001 dpict ( draw signature picture ) .arrows ; : P3 cls scr ." Code produced by Pocket Forth is compact and fast." cr scr ." Pocket Forth produces true machine code, so" scr ." you have complete control over your program." cr scr ." Examine and run the example and extension" scr ." files for programming suggestions." cr scr ." If you have system 7 you can load text files by" scr ." dragging a text file icon onto Pocket Forth's icon." cr scr ." All systems can use the menu to “Open” a file." 143 392 176 425 irect !rect ( set icon rect ) 128 irect .icon ( draw the icon ) .arrows ; : P4 cls scr ." Print and read the Manual and the Glossary." cr scr ." The Manual consists of two TeachText documents" scr ." suitable for use as a reference to Pocket Forth." cr scr ." The Glossary, also a TeachText document, is a" scr ." list of the words in the Pocket Forth dictionary." scr ." Stack effects, pronunciation and usage are shown." cr scr ." An addendum describes the desk accessory." cr scr ." Other document files abound." scr .arrows ; : P5 cls scr ." Major changes since release 5:" scr scr ." • Floating point numbers!" cr scr ." Numeric input containing a decimal point is" scr ." interpreted as an extended floating point" scr ." number. Floating Point numbers are kept on" scr ." the stack as ten byte entities." cr scr ." SANE is used along with three dozen new" scr ." words that manipulate floating point numbers." cr scr scr ." ( continued ... )" .arrows ; : P6 cls scr ." Floating point continued ..." cr scr ." Stack words: " 2 !face ." fdrop fdup fswap fpick" scr ." fpack froll f>d d>f" cr scr 0 !face ." Memory words: " 2 !face ." f@ f! fliteral f," scr ." fconstant fvariable" cr scr 0 !face ." I/O words: " 2 !face ." fnumber sci fix f." cr scr 0 !face ." Math words: " 2 !face ." fcompare f+ f- f* f/" scr ." frem f^ fint fabs fsqrt" scr ." fsin fcos ftan fatn" scr ." fexp fln" 0 !face .arrows ; : P7 cls scr ." • Apple Events:" cr scr 21 352 54 385 irect !rect ( set icon rect ) 128 irect .icon ( draw the icon ) ." Apple Events (System 7 required) are the" scr ." standard conduit for inter-application" scr ." communication. Pocket Forth programs may" scr ." define new Apple event handlers. The four" scr ." required events and all user defined events" scr ." are installed automatically when Pocket" scr ." Forth starts." cr scr ." Examples for HyperCard and Frontier are" scr ." in the 'Extensions:Apple Events' folder." cr scr ." ( continued ... )" .arrows ; : P8 cls scr ." New words and variables control Apple Events:" cr scr 2 !face ." AE: " 0 !face ." and " 2 !face ." AE: " 0 !face ." begin and end event definitions" scr 2 !face ." ,S " 0 !face ." compile (or stack) 4 bytes from ASCII" cr scr 2 !face ." +Md " 0 !face ." variables:" scr ." 136 Apple Event handler routine" scr ." 188 Address of installation list" scr ." 190 Error handler routine (" 2 !face ." drop " 0 !face ." )" scr ." 198 Reply record handle holder" scr ." 202 Apple Event record handle" .arrows ; : P9 cls scr ." • Use " 2 !face ." ?gestalt " 0 !face ." to query the system." cr scr ." Using this new system trap, available since" scr ." late system 6, you can determine much about" scr ." the system software and hardware." scr scr ." • A color conscious window is created if a" scr ." color machine is in use. This has no visual" scr ." effect but allows your programs to use color." scr scr ." • A new color icon and signature is used." 336 216 !pen lfont ." p4TH" sfont 175 335 207 367 irect !rect ( set icon rect ) 129 irect .icon ( draw the icon ) .arrows ; : P10 cls scr ." New for 6.3:" cr scr ." • The word \ makes comments more effecitve." cr scr ." • " 2 !face ." Warm " 0 !face ." restarts Pocket Forth, but leaves" scr ." the dictionary intact." cr scr ." • " 2 !face ." Depth " 0 !face ." lets you know how many items are" scr ." on the stack." scr scr ." • Check out the Balloon Help." .arrows ; : P11 cls scr ." Bug fixes:" cr scr ." • The manual has been updated and now" scr ." prints with pictures, without errors." cr scr ." • " 2 !face ." Back " 0 !face ." now compiles correct branches." cr scr ." • A 32 bit address error in the update" scr ." routine has been fixed." cr scr ." • A new word, " 2 !face ." Bye " 0 !face ." does not use _ExitToShell." scr scr scr ." ( continued ... )" .arrows ; : P12 cls scr ." Bug fixes, continued ... (New for 6.3)" cr scr ." • " 2 !face ." +LOOP " 0 !face ." now works correctly with" scr ." negative arguments." cr scr ." • " 2 !face ." TYPE " 0 !face ." does not end with a space." cr scr ." • " 2 !face ." QUIT " 0 !face ." leaves the stack untouched." cr scr ." • Tabs are now converted to spaces before" scr ." interpreting, so they no longer cause errors." .arrows ; : P13 cls scr ." Notes:" cr scr ." • A DA version is now included. Version 1.6.3" scr ." includes all of the new features except for" scr ." Apple Events support." cr scr ." • " 2 !face ." Grow " 0 !face ." has been removed from the application." scr ." Allocated memory is 32K for both application" scr ." and DA." cr scr ." • Choosing “Save” from the menu confirms your" scr ." choice before overwriting the dictionary." cr scr ." ( continued ... )" .arrows ; : P14 cls scr ." Notes, continued ..." cr scr ." • 68040's instruction cache must be disabled" scr ." to correctly compile code." cr scr ." • The floating point interpreter will attempt" scr ." to convert any undefined token to a number." scr ." If the token begins with a number, it will" scr ." be converted causing unexpected results." cr scr ." • Numerous code tightening and speed up" scr ." enhancements have been made." .arrows ; : P15 cls scr ." Packing list for Pocket Forth, release 6.3:" scr scr ." • The application, Pocket Forth version 0.6.3" scr ." • The desk accessory, PocketDA version 1.6.3" cr scr ." Text files:" scr ." • The Manual parts 1 and 2" scr ." • The Glossary of Pocket Forth words" scr ." • Source code with assembly instructions" scr ." and an assembly script for Frontier." scr ." • Source and Manual Addendum for the DA." cr scr scr ." ( continued ... )" .arrows ; : P16 cls scr ." • Example folder: (Packing list cont.)" cr scr ." create this application" bcr ." Reader" scr ." the guts of a text editor" bcr ." TextEdit" scr ." the Sieve of Erastothanes" bcr ." Sieve" scr ." demonstrate them" bcr ." Window&Menu" scr ." read and write ASCII data files" bcr ." DataFiles" scr ." floating point trig. functions" bcr ." SANETrig" scr ." 16/32 bit math functions" bcr ." IntegerTrig" scr ." QuickDraw routines with demo" bcr ." Graphics" scr ." an RPN scientific calculator" bcr ." Calculator" cr scr scr ." ( continued ... )" .arrows ; : P17 cls scr ." • Extension folder: (Packing list cont.)" cr scr ." Make Pocket Forth mostly" bcr ." Starting folder" scr ." compatable with " 4 !face ." Starting" bcr nfont 2 !face ." ATTENTION" 0 !face sfont scr ." " 4 !face ." Forth" 0 !face ." by Leo Brodie!" bcr nfont 2 !face ." BEGINNERS!" 0 !face sfont cr scr ." A folder with new event" bcr ." Apple Events" scr ." definitions and interface files" scr ." for Frontier and HyperCard." cr scr ." A library of utility routines." bcr ." Misc" cr scr ." The Forth Vendors Group" bcr ." fvgFloatingPoint" scr ." floating point standard." 128 94 161 127 irect !rect ( set icon rect ) 128 irect .icon ( draw the icon ) .arrows ; : P18 cls scr ." • Extras folder: (Disk packing list only)" cr scr ." test your esp with cards" bcr ." Rhine" scr ." create the Rhine application" bcr ." Rhiner" scr ." test random numbers" bcr ." RandomTest" cr scr ." use Frontier to revert a saved" bcr ." RevertDICT" scr ." Pocket Forth dictionary to its" scr ." default state" .arrows ; : P19 cls scr ." If you find a bug, need help, or want to talk" scr ." about this, write. I'd like to hear from you and" scr ." I'll attempt to answer your mail." cr scr ." Do not send any money, Pocket Forth is free!" cr scr ." Contact me at any of the following addresses:" scr ." CompuServe [70566,1474]" scr ." AOL cheilman" scr ." Email “heilman@pc.maricopa.edu”" scr ." U.S. Mail PO box 8345" scr ." Phoenix AZ 85066-8345" .aarrow ; \ page list variable PWHICH 0 pwhich ! ( page-1 to be drawn ) 18 constant PNO ( number of pages-1 ) create PLIST ( ordered list of routines or "pages" ) ' p1 , ' p2 , ' p3 , ' p4 , ' p5 , ' p6 , ' p7 , ' p8 , ' p9 , ' p10 , ' p11 , ' p12 , ' p13 , ' p14 , ' p15 , ' p16 , ' p17 , ' p18 , ' p19 , ( update, menu, button and idle handlers ) : DOUP pwhich @ 2* plist + @ execute ; ( draw the pwhichth page ) : DON ( n -- ) pwhich ! doup ; ( go to nth page ) : DOAFT pwhich @ 1 - 0 max don ; ( decrement pwhich ) : DOFOR pwhich @ 1+ pno min don ; ( increment pwhich ) : DOFIRST 0 don ; ( go to first page ) : DOLAST pno don ; ( go to last page ) : DONEW 4 don ; \ go to "whats new" page : DOBUG 10 don ; \ go to "bug fixes" page : DONOTE 12 don ; \ go to "notes" page : DOPACK 14 don ; \ go to "packing list" page : STOP -bird bye ; ( stop animating ) \ menu list create GMENU ' dofirst , ' doaft , ' dofor , ' dolast , ' null , ' donew , ' dobug , ' donote , ' dopack , ' dolast , create FMENU ' stop , create MBAR fmenu , 18 +md @ 2+ @ , gmenu , 2variable GMENUH 0 0 gmenuh 2! ( holder for goMenuHandle ) ' beep 18 +md @ ( get pointer to menu list ) 2+ @ ( get pointer to Edit menu from menu list ) 8 + ! ( set paste handler to beep ) : +MENU ( -- ) ( Turn the new menu on.) 0 0 2>r 4 >r ,$ A9BF ( _GetRMenu ) 2r> 2dup 2>r 0 >r ,$ A935 ( _InsertMenu ) gmenuh 2! ,$ A937 ; ( _DrawMenuBar ) : DOBUTT ( -- ) ( button handler ) @mouse apoly ?phit IF apoly 2@ 2>r ,$ A8C9 doaft ELSE @mouse fpoly ?phit IF fpoly 2@ 2>r ,$ A8C9 dofor THEN THEN ; \ Idle procedure variable TLAST 0 tlast ! ( timer ) 10 constant DELAY : TICKS ( -- n ) 364 0 l@ ; : ?TIME ( -- flags ) ( true if 1/delay seconds has elapsed ) ticks tlast @ - abs delay > ; : DOIDLE ( do the first page animation ) pwhich @ 0= IF ( if its the title page ) ?time IF ticks tlast ! animate THEN THEN ; \ startup procedure : START sfont \ Set to 12 point Chicago font in srcCopy mode. +apoly +fpoly \ This is stuff that must +menu +bird \ be set up at runtime, 128 +icon 129 +icon \ because it uses handles. BEGIN ?terminal drop AGAIN ; ( event loop ) \ This is event handlers and data to set up when this is loaded. ' doup 14 +md ! \ set update handler ' dobutt 16 +md ! \ set button handler mbar 18 +md ! \ set the menu handlers ' doidle 20 +md ! \ set idle handler ' stop 22 +md ! \ set quit handler ' start 26 +md ! \ set startup handler ' null 136 +md ! \ disable Apple Events 450 250 8 +md 2! \ set window size save bye